home *** CD-ROM | disk | FTP | other *** search
/ Software Vault: The Gold Collection / Software Vault - The Gold Collection (American Databankers) (1993).ISO / cdr10 / froff.zip / FIXCRLF.FOR < prev    next >
Text File  |  1993-01-14  |  27KB  |  738 lines
  1. C     RENBR(FIXCRLF/CUT FILE INTO EQUAL LENGTH LINES)
  2. C
  3. C     BY DONALD E. BARTH
  4. C
  5.       CHARACTER*1 LTRNOW,LTRONE,LTRTWO,LTRLIN(80),CHAR
  6.       CHARACTER*80 FILINP,FILOUT
  7.       DATA LMTLIN/80/
  8.       DATA ITTY,JTTY,IDISK,JDISK/0,0,1,2/
  9. C
  10. C     IDENTIFY THIS PROGRAM
  11.       WRITE(JTTY,1)
  12.     1 FORMAT(' FIXCRLF'/
  13.      1' Inserts CRLF after fixed length records.'/
  14.      1' Removes nulls and EOFs,',
  15.      1' and converts FF or lone CR or LF to CRLF.')
  16. C
  17. C     OPEN NEXT INPUT FILE
  18.     2 WRITE(JTTY,3)
  19.     3 FORMAT(' Input file? ',\)
  20.       READ(ITTY,4)FILINP
  21.     4 FORMAT(1A80)
  22.       IF(FILINP.EQ.' ')GO TO 6
  23.       OPEN(UNIT=IDISK,FILE=FILINP,STATUS='OLD',IOSTAT=ICHECK,
  24.      1 FORM='BINARY')
  25.       IF(ICHECK.EQ.0)GO TO 8
  26.       WRITE(JTTY,5)
  27.     5 FORMAT(' Cannot open input file')
  28.       GO TO 2
  29.     6 WRITE(JTTY,7)
  30.     7 FORMAT(' Name of input file must be specified')
  31.       GO TO 2
  32.     8 CONTINUE
  33. C
  34. C     OPEN OUTPUT FILE
  35.     9 WRITE(JTTY,10)
  36.    10 FORMAT(' Output file? ',\)
  37.       READ(ITTY,11)FILOUT
  38.    11 FORMAT(1A80)
  39.       IF(FILOUT.EQ.' ')GO TO 15
  40.       OPEN(UNIT=JDISK,FILE=FILOUT,STATUS='OLD',IOSTAT=ICHECK)
  41.       IF(ICHECK.NE.0)GO TO 17
  42.       CLOSE(UNIT=JDISK)
  43.    12 WRITE(JTTY,13)
  44.    13 FORMAT(' File already exists. Replace it? ',\)
  45.       READ(ITTY,14)LTRNOW
  46.    14 FORMAT(1A1)
  47.       IF(LTRNOW.EQ.'Y')GO TO 17
  48.       IF(LTRNOW.EQ.'y')GO TO 17
  49.       IF(LTRNOW.EQ.'N')GO TO 9
  50.       IF(LTRNOW.EQ.'n')GO TO 9
  51.       GO TO 12
  52.    15 WRITE(JTTY,16)
  53.    16 FORMAT(' Name of output file must be specified')
  54.       GO TO 9
  55.    17 OPEN(UNIT=JDISK,FILE=FILOUT,STATUS='NEW',IOSTAT=ICHECK,
  56.      1 FORM='BINARY')
  57.       IF(ICHECK.EQ.0)GO TO 19
  58.       WRITE(JTTY,18)
  59.    18 FORMAT(' Cannot open output file')
  60.       GO TO 9
  61.    19 CONTINUE
  62. C
  63. C     ASK LENGTH OF LINES
  64.    20 WRITE(JTTY,21)
  65.    21 FORMAT(
  66.      1' Line length not counting CRLF (0 to only change LF to CRLF)? ',
  67.      2\)
  68.       READ(ITTY,22)LTRLIN
  69.    22 FORMAT(9999A1)
  70. C     SUBROUTINE DAHEFT(KONTRL,ITRAIL,IEXTRA,IBUFFR,MAXBFR,
  71. C    1    LOWBFR,KIND  ,ISHIFT,JSHIFT,KSHIFT,LSHIFT,IVALUE,
  72. C    2    VALUE )
  73.       LOWBFR=1
  74.       CALL DAHEFT(0,0,0,LTRLIN,LMTLIN,
  75.      1 LOWBFR,KIND,ISHIFT,JSHIFT,KSHIFT,LSHIFT,IVALUE,
  76.      2 VALUE )
  77.       IF(KIND.NE.3)GO TO 25
  78.       IF(IVALUE.LT.0)GO TO 25
  79.    23 IF(LOWBFR.GT.LMTLIN)GO TO 24
  80.       IF(LTRLIN(LOWBFR).NE.' ')GO TO 25
  81.       LOWBFR=LOWBFR+1
  82.       GO TO 23
  83.    24 GO TO 27
  84.    25 WRITE(JTTY,26)
  85.    26 FORMAT(
  86.      1' Type the length of the lines into',
  87.      2' which the file is to be split.'/
  88.      3' Do not include the trailing CRLF in this line length.'/
  89.      4' Type zero to merely change lone LF characters to CRLF pairs')
  90.       GO TO 20
  91.    27 LNGLIN=IVALUE
  92. C
  93. C     INITIALIZE
  94. C
  95. C     KNTINP = NUMBER OF CHARACTERS READ FROM INPUT FILE
  96. C     KNTOUT = NUMBER OF CHARACTERS WRITTEN TO OUTPUT FILE
  97. C     KNTLIN = NUMBER OF END OF LINES WRITTEN
  98. C     IONLIN = LENGTH OF LINE NOW BEING OUTPUT
  99. C     NEWLIN = NUMBER OF END OF LINES STILL TO BE OUTPUT
  100. C     KNTCR  = NUMBER OF CARRIAGE RETURNS NOT YET OUTPUT
  101. C     KNTLF  = NUMBER OF LINE FEEDS NOT YET OUTPUT
  102. C     MSTLIN = LENGTH OF LONGEST OUTPUT LINE
  103. C
  104.       KNTINP=0
  105.       KNTOUT=0
  106.       KNTLIN=0
  107.       IONLIN=0
  108.       NEWLIN=0
  109.       KNTCR=0
  110.       KNTLF=0
  111.       MSTLIN=0
  112.       KNTNUL=0
  113.       KNTEOF=0
  114. C
  115. C     COPY THE FILE, INSERTING END OF LINES AS NEEDED
  116.    28 READ(IDISK,END=33)LTRONE
  117.       KNTINP=KNTINP+1
  118.       KODE=ICHAR(LTRONE)
  119.       IF(KODE.EQ.0)GO TO 40
  120.       IF(KODE.EQ.10)GO TO 31
  121.       IF(KODE.EQ.12)GO TO 31
  122.       IF(KODE.EQ.13)GO TO 32
  123.       IF(KODE.EQ.26)GO TO 426
  124.       IF(NEWLIN.NE.0)GO TO 29
  125.       IF(LNGLIN.LE.0)GO TO 30
  126.       IF(IONLIN.LT.LNGLIN)GO TO 30
  127. C
  128. C     INSERT   CR = 13   LF = 10   AT START OF NEW LINE
  129.    29 LTRTWO=CHAR(13)
  130.       WRITE(JDISK)LTRTWO
  131.       LTRTWO=CHAR(10)
  132.       WRITE(JDISK)LTRTWO
  133.       KNTOUT=KNTOUT+2
  134.       NEWLIN=NEWLIN-1
  135.       KNTLIN=KNTLIN+1
  136.       CALL RUNLIN(KNTLIN,ITTY,JTTY)
  137.       IF(NEWLIN.GT.0)GO TO 29
  138.       KNTCR=0
  139.       KNTLF=0
  140.       NEWLIN=0
  141.       IONLIN=0
  142. C
  143. C     OUTPUT THE SINGLE NEW CHARACTER
  144.    30 KNTOUT=KNTOUT+1
  145.       IONLIN=IONLIN+1
  146.       WRITE(JDISK)LTRONE
  147.       IF(MSTLIN.LT.IONLIN)MSTLIN=IONLIN
  148.       GO TO 28
  149. C
  150. C     LINE FEED (10) OR FORM FEED (12)
  151.    31 KNTLF=KNTLF+1
  152.       NEWLIN=KNTLF
  153.       IF(NEWLIN.LT.KNTCR)NEWLIN=KNTCR
  154.       GO TO 28
  155. C
  156. C     CARRIAGE RETURN (13)
  157.    32 KNTCR=KNTCR+1
  158.       NEWLIN=KNTLF
  159.       IF(NEWLIN.LT.KNTCR)NEWLIN=KNTCR
  160.       GO TO 28
  161. C
  162. C     NULL (0)
  163.    40 KNTNUL=KNTNUL+1
  164.       GO TO 28
  165. C
  166. C     END OF FILE (26)
  167.   426 KNTEOF=KNTEOF+1
  168.       GO TO 28
  169. C
  170. C     INSERT   CR = 13   LF = 10  AT END OF FILE
  171.    33 IF(NEWLIN.NE.0)GO TO 34
  172.       IF(IONLIN.EQ.0)GO TO 35
  173.    34 LTRTWO=CHAR(13)
  174.       WRITE(JDISK)LTRTWO
  175.       LTRTWO=CHAR(10)
  176.       WRITE(JDISK)LTRTWO
  177.       KNTOUT=KNTOUT+2
  178.       NEWLIN=NEWLIN-1
  179.       KNTLIN=KNTLIN+1
  180.       CALL RUNLIN(KNTLIN,ITTY,JTTY)
  181.       IF(NEWLIN.GT.0)GO TO 34
  182.    35 CONTINUE
  183. C
  184. C     ALL DONE
  185.       WRITE(JTTY,36)KNTINP
  186.       WRITE(JTTY,37)KNTOUT
  187.       WRITE(JTTY,38)KNTLIN
  188.       WRITE(JTTY,39)MSTLIN
  189.       WRITE(JTTY,41)KNTNUL
  190.       WRITE(JTTY,526)KNTEOF
  191.    36 FORMAT(' ',1I10,' bytes read')
  192.    37 FORMAT(' ',1I10,' bytes written')
  193.    38 FORMAT(' ',1I10,' lines written')
  194.    39 FORMAT(' ',1I10,' length of longest output line')
  195.    41 FORMAT(' ',1I10,' null characters removed')
  196.   526 FORMAT(' ',1I10,' EOF characters removed')
  197. C
  198. C     ALL DONE
  199.       END
  200.       SUBROUTINE RUNLIN(LINE,ITTY,JTTY)
  201.       IF(LINE.EQ.1)WRITE(JTTY,1)LINE
  202.       IF(LINE.GT.        1.AND.LINE.LT.        10)WRITE(JTTY,2)LINE
  203.       IF(LINE.GE.       10.AND.LINE.LT.       100)WRITE(JTTY,3)LINE
  204.       IF(LINE.GE.      100.AND.LINE.LT.      1000)WRITE(JTTY,4)LINE
  205.       IF(LINE.GE.     1000.AND.LINE.LT.     10000)WRITE(JTTY,5)LINE
  206.       IF(LINE.GE.    10000.AND.LINE.LT.    100000)WRITE(JTTY,6)LINE
  207.       IF(LINE.GE.   100000.AND.LINE.LT.   1000000)WRITE(JTTY,7)LINE
  208.       IF(LINE.GE.  1000000.AND.LINE.LT.  10000000)WRITE(JTTY,8)LINE
  209.       IF(LINE.GE. 10000000.AND.LINE.LT. 100000000)WRITE(JTTY,9)LINE
  210.       IF(LINE.GE.100000000.AND.LINE.LT.1000000000)WRITE(JTTY,10)LINE
  211. C                123456789             1234567890
  212.     1 FORMAT(' ',1I1)
  213.     2 FORMAT('+',1I1)
  214.     3 FORMAT('+',1I2)
  215.     4 FORMAT('+',1I3)
  216.     5 FORMAT('+',1I4)
  217.     6 FORMAT('+',1I5)
  218.     7 FORMAT('+',1I6)
  219.     8 FORMAT('+',1I7)
  220.     9 FORMAT('+',1I8)
  221.    10 FORMAT('+',1I9)
  222.       RETURN
  223.       END
  224.       SUBROUTINE DAHEFT(KONTRL,ITRAIL,IEXTRA,IBUFFR,MAXBFR,
  225.      1    LOWBFR,KIND  ,ISHIFT,JSHIFT,KSHIFT,LSHIFT,IVALUE,
  226.      2    VALUE )
  227. C     RENBR(/FREE FORMAT NUMERIC INPUT ROUTINE)
  228. C
  229. C     DONALD BARTH, HARVARD BUSINESS SCHOOL
  230. C
  231. C     DAHEFT  INTERPRETS  AN  ARRAY  READ  BY  THE  CALLING
  232. C     PROGRAM  WITH  A MULTIPLE OF AN A1 FORMAT AND RETURNS
  233. C     THE VALUES CONTAINED IN THIS  ARRAY.
  234. C
  235. C     NUMBERS  INTERPRETTED  BY  DAHEFT CAN CONTAIN LEADING
  236. C     SIGN, EMBEDDED DECIMAL POINT AND/OR TRAILING  E  WITH
  237. C     SIGNED EXPONENT.  A PERCENT SIGN FOLLOWING THE NUMBER
  238. C     IMPLIES  E-2,  TRAILING  LETTER  K  IMPLIES  E3   AND
  239. C     TRAILING LETTER M IMPLIES E6.
  240. C
  241. C     ARGUMENT LIST DEFINITIONS:
  242. C
  243. C     KONTRL = 1  OR  GREATER,  ITEM  IN  IBUFFR  ARRAY  IS
  244. C              FLOATING  POINT.   IF POSSIBLE, THE FLOATING
  245. C              POINT  NUMBER  WILL  BE  ACCUMULATED  AS  AN
  246. C              INTEGER, THEN BE CONVERTED TO FLOATING POINT
  247. C              AND SHIFTED IF NECESSARY.   KONTRL  IS  THEN
  248. C              THE MAXIMUM NUMBER OF DIGITS IN THE INTEGER.
  249. C              THE VALUE IS OUTPUT AS THE  ARGUMENT  VALUE.
  250. C              IF  THE  ITEM  HAS  MORE THAN KONTRL DIGITS,
  251. C              THEN  THE  ENTIRE  EVALUATION  IS  DONE   IN
  252. C              FLOATING    POINT.     THE    ADVANTAGE   OF
  253. C              CALCULATING THE  FLOATING  POINT  VALUES  IN
  254. C              INTEGER  AS  LONG  AS  THE  PRECISION OF THE
  255. C              COMPUTER  IS  NOT  OVERFLOWED  IS  THAT  THE
  256. C              CALCULATION  OF  THE  PORTION  OF THE NUMBER
  257. C              RIGHT OF THE DECIMAL POINT  IS  MORE  EXACT.
  258. C              AS  AN EXAMPLE, IF KONTRL IS GREATER THAN OR
  259. C              EQUAL TO 4, THEN THE  NUMBER  33.33  CAN  BE
  260. C              STORED   AS   THE   INTEGER  3333,  THEN  BE
  261. C              CONVERTED TO FLOATING POINT VALUE 3333.0 AND
  262. C              DIVIDED   BY  100.0  TO  OBTAIN   THE  FINAL
  263. C              ANSWER.  IF IT MAKES NO  DIFFERENCE  WHETHER
  264. C              THE NUMBER TYPED AS 33.33 HAS VALUE 33.33 OR
  265. C              33.32999...  THEN KONTRL CAN  BE  GIVEN  THE
  266. C              VALUE 1.
  267. C            = 0, ITEM IN IBUFFR ARRAY IS INTEGER  DECIMAL.
  268. C              THE NUMBER CAN BE TYPED WITH A DECIMAL POINT
  269. C              (FOR EXAMPLE 1.23K OR 1.23E3  EQUALS  1230),
  270. C              BUT  IS  STORED AS AN INTEGER IN DAHEFT, AND
  271. C              IS OUTPUT  AS ARGUMENT IVALUE.   ANY DECIMAL
  272. C              INTEGER WHICH THE COMPUTER CAN REPRESENT CAN
  273. C              BE  EVALUATED.    THIS  INCLUDES,   ON  TWOS
  274. C              COMPLEMENT  COMPUTERS, THE  LARGEST NEGATIVE
  275. C              NUMBER THE ABSOLUTE VALUE OF WHICH CANNOT BE
  276. C              STORED.   ON THE  PDP10,  A 36 BIT  COMPUTER
  277. C              WITH TWOS COMPLEMENT  NOTATION, THE RANGE OF
  278. C              DECIMAL  INTEGERS  IS  -34359738368  THROUGH
  279. C              34359738367  (OCTAL NOTATION OF BIT PATTERNS
  280. C              BEING  400000000000  THROUGH  377777777777).
  281. C            = -1, ITEM IN  IBUFFR  ARRAY  IS  OCTAL.   THE
  282. C              NUMBER  CAN  BE  TYPED  WITH A DECIMAL POINT
  283. C              AND/OR  WITH  AN  EXPONENT.   HOWEVER,   THE
  284. C              NUMBER   FOLLOWING   THE  LETTER  E  OF  THE
  285. C              EXPONENT IS EVALUATED IN DECIMAL.  THE VALUE
  286. C              OF  THE  OCTAL  NUMBER  IS  RETURNED  AS THE
  287. C              ARGUMENT  IVALUE.   IT  MUST  BE NOTED  THAT
  288. C              NUMBERS EVALUATED AS NEGATIVE OCTAL INTEGERS
  289. C              HAVE THE  NEGATIVE  OCTAL  INTEGER  AS THEIR
  290. C              VALUE,  NOT AS  THEIR BIT  REPRESENTATION IN
  291. C              COMPUTER STORAGE.   FOR EXAMPLE, ON A 36 BIT
  292. C              TWOS COMPLEMENT  COMPUTER,  THE OCTAL NUMBER
  293. C              -400000000000 (WHICH COULD  ALSO BE TYPED AS
  294. C              -4E11 OR -4E+11 WHERE  THE 11 AFTER THE E IS
  295. C              IN DECIMAL)  IS REPRESENTED  AS BIT  PATTERN
  296. C              HAVING OCTAL  NOTATION  400000000000 AND THE
  297. C              OCTAL NUMBER -377777777777 IS REPRESENTED BY
  298. C              THE BIT PATTERN 400000000001.
  299. C            = -2, DO  NOT  EVALUATE NUMBERS.   INSTEAD THE
  300. C              CHARACTERS  FORMING NUMBER  ARE TREATED LIKE
  301. C              ANY OTHER PRINTING CHARACTERS.
  302. C     ITRAIL = SPECIFIES  WHETHER  EXPONENTS  ARE   TO   BE
  303. C              RECOGNIZED.
  304. C            = -1,  ALLOW  NUMBERS  TO  BE  FOLLOWED  BY  E
  305. C              EXPONENT, BUT DO NOT RECOGNIZE PERCENT SIGN,
  306. C              K  OR  M  AT  END  OF  NUMBER.   E  IS   NOT
  307. C              RECOGNIZED  IF NOT PRECEDED BY SIGN, DECIMAL
  308. C              POINT OR DIGIT.
  309. C            = 0, DO NOT ALLOW TRAILING PERCENT SIGN,  K  M
  310. C              OR E EXPONENT.
  311. C            = 1, ALLOW NUMBERS TO BE FOLLOWED  BY  PERCENT
  312. C              SIGN,  K M OR E EXPONENT.  PERCENT SIGN, K M
  313. C              OR E IS NOT RECOGNIZED IF  NOT  PRECEDED  BY
  314. C              SIGN, DECIMAL POINT OR DIGIT.
  315. C
  316. C            FOLLOWING VALUES DO NOT REQUIRE THAT  EXPONENT
  317. C            BE  PRECEDED  BY  NUMBER.   ALTHOUGH  RETURNED
  318. C            VALUE WILL ALWAYS BE ZERO IF NO  VALUE  DIGITS
  319. C            ARE  FOUND,  CALLING PROGRAM COULD ADJUST THIS
  320. C            RETURNED VALUE.
  321. C
  322. C            = -3,  LEADING  E  EXPONENT   IS   RECOGNIZED.
  323. C              LEADING DIGITS, SIGNS AND DECIMAL POINTS ARE
  324. C              NOT ALLOWED.
  325. C            = -2,  SAME  AS  ITRAIL=-1,  EXCEPT  THAT   IN
  326. C              ADDITION  E  EXPONENT  IS RECOGNIZED EVEN IF
  327. C              NOT PRECEDED  BY  DIGITS,  SIGN  OR  DECIMAL
  328. C              POINT.
  329. C            = 2, SAME AS ITRAIL=1, EXCEPT THAT IN ADDITION
  330. C              LEADING  PERCENT  SIGN,  OR LETTERS K M OR E
  331. C              EXPONENT ARE RECOGNIZED EVEN IF NOT PRECEDED
  332. C              BY DIGITS, SIGN OR DECIMAL POINT.
  333. C            = 3, ONLY LEADING PERCENT SIGN OR LETTERS K  M
  334. C              OR   E  EXPONENT  ARE  RECOGNIZED.   LEADING
  335. C              DIGITS, SIGNS  OR  DECIMAL  POINTS  ARE  NOT
  336. C              ALLOWED.
  337. C
  338. C            IF 10 IS  SUBTRACTED  FROM  ITRAIL  VALUES  -3
  339. C            THROUGH  3,  AND  IF  EITHER  VALUE  DIGITS OR
  340. C            DIGITS FOLLOWING LETTER E  ARE  MISSING,  THEN
  341. C            ONE,  RATHER  THAN  ZERO, IS ASSUMED TO BE THE
  342. C            DEFAULT  FOR  THE  VALUE   OR   THE   EXPONENT
  343. C            RESPECTIVELY.   -E-  WOULD  BE  EQUIVALENT  TO
  344. C            -1E-1 AND -E OR -E+  WOULD  BE  EQUIVALENT  TO
  345. C            -1E1
  346. C
  347. C            IF 10 IS ADDED TO ITRAIL VALUES -3 THROUGH  3,
  348. C            THEN  VALUE  IS  RETURNED  AS  THOUGH  NEITHER
  349. C            EXPONENT NOR DECIMAL  POINT  HAD  BEEN  TYPED.
  350. C            VALUE  INDICATED  BY  COMBINATION  OF  DIGITS,
  351. C            DECIMAL POINT AND/OR EXPONENT CAN BE  OBTAINED
  352. C            AS   VALUE*10**KSHIFT   OR  IVALUE*10**KSHIFT.
  353. C            VALUE INDICATED BY COMBINATION OF  DIGITS  AND
  354. C            DECIMAL  POINT  BUT  IGNORING  EXPONENT CAN BE
  355. C            OBTAINED   AS   VALUE*10**(KSHIFT-JSHIFT)   OR
  356. C            IVALUE*10**(KSHIFT-JSHIFT).
  357. C     IEXTRA = EXTRA SHIFT TO BE APPLIED TO  VALUE.   SHIFT
  358. C              IS  STATED  AS  POWER  OF  RADIX.   THIS  IS
  359. C              APPLIED IN ADDITION  TO  SHIFT  REPORTED  IN
  360. C              ISHIFT,  JSHIFT  AND  KSHIFT AS SPECIFIED BY
  361. C              USER.  FOR EXAMPLE, IF DOLLAR VALUE IS TO BE
  362. C              RETURNED  AS INTEGER NUMBER OF CENTS, IEXTRA
  363. C              WOULD HAVE VALUE 2.
  364. C     IBUFFR = INPUT  BUFFER  ARRAY  CONTAINING  CHARACTERS
  365. C              TYPED BY USER,  READ BY A  MULTIPLE OF AN A1
  366. C              FORMAT,  WHICH IS  TO BE SEARCHED  FOR WORDS
  367. C              AND NUMBERS.   IBUFFR THEN CONTAINS 1 LETTER
  368. C              PER COMPUTER STORAGE LOCATION.
  369. C     MAXBFR = MAXIMUM SUBSCRIPT  OF  IBUFFR  ARRAY  TO  BE
  370. C              SEARCHED
  371. C     LOWBFR = SUBSCRIPT WITHIN THE  IBUFFR  ARRAY  OF  THE
  372. C              FIRST  (LEFTMOST)  CHARACTER  WHICH  CAN  BE
  373. C              SCANNED FOR NUMBERS. LOWBFR WILL BE RETURNED
  374. C              POINTING TO FIRST  PRINTING  CHARACTER WHICH
  375. C              CANNOT APPEAR IN A NUMBER, OR BEYOND THE END
  376. C              OF THE BUFFER IF THE BUFFER DOES NOT CONTAIN
  377. C              ANY PRINTING CHARACTERS.
  378. C     KIND   = RETURNED DESCRIBING THE KIND OF ITEM LOCATED
  379. C              IN THE IBUFFR ARRAY.
  380. C            = 1, NOTHING  WAS FOUND AT OR  TO THE RIGHT OF
  381. C              LOWBFR.  THE  CALLING  PROGRAM SHOULD READ A
  382. C              NEW LINE INTO IBUFFR.
  383. C            = 2, NUMBER  WAS  NOT  FOUND,  BUT A  PRINTING
  384. C              CHARACTER  WHICH CANNOT  START A  NUMBER WAS
  385. C              FOUND.   LOWBFR IS RETURNED POINTING TO THIS
  386. C              PRINTING CHARACTER.
  387. C            = 3, A NUMBER  WAS FOUND.   LOWBFR IS RETURNED
  388. C              POINTING TO CHARACTER TO RIGHT OF NUMBER.
  389. C     ISHIFT = 0, RETURNED IF NONE OF CHARACTERS E, %, K OR
  390. C              M FOLLOW NUMBER
  391. C            = 1, PERCENT SIGN FOLLOWS NUMBER
  392. C            = 2, K FOLLOWS NUMBER
  393. C            = 3, M FOLLOWS NUMBER
  394. C            = LESS  THAN  ZERO,  RETURNED  IF  E   FOLLOWS
  395. C              NUMBER.
  396. C            = -1, E  AND  POSSIBLY  SIGNED  NUMBER  FOLLOW
  397. C              NUMBER.
  398. C            = -2, E IS FOLLOWED BY PLUS SIGN NOT  IN  TURN
  399. C              FOLLOWED BY DIGITS.
  400. C            = -3, E IS FOLLOWED BY MINUS SIGN NOT IN  TURN
  401. C              FOLLOWED BY DIGITS.
  402. C            = -4, E IS FOLLOWED BY NEITHER SIGN NOR DIGITS
  403. C     JSHIFT = EXPONENT  INDICATED  BY  FOLLOWING   PERCENT
  404. C              SIGN, K, M OR E  FOLLOWED BY DIGITS.    THIS
  405. C              WILL HAVE BEEN APPLIED TO RETURNED VALUE  IF
  406. C              ITRAIL  EQUALS  EITHER  -1  OR 1.  12.34K OR
  407. C              12.34E3 WOULD GIVE  JSHIFT  OF  3.   12%  OR
  408. C              12E-2 WOULD GIVE JSHIFT -2.
  409. C     KSHIFT = EXPONENT WHICH WOULD BE NECESSARY TO  OBTAIN
  410. C              DESIRED  VALUE  IF  NUMBER  HAD  BEEN  TYPED
  411. C              WITHOUT DECIMAL POINT.  12.34 STATED WITHOUT
  412. C              DECIMAL  POINT  WOULD  BE  1234E-2 SO KSHIFT
  413. C              WOULD BE -2.   12.34K  WOULD  BE  1234E1  SO
  414. C              KSHIFT WOULD BE 1.
  415. C     LSHIFT = ZERO  OR  LESS,  THE  VALUE  ZERO  IS  BEING
  416. C              RETURNED   FOR   EITHER   VALUE  OR  IVALUE,
  417. C              WHICHEVER IS APPROPRIATE.
  418. C            = -4, NUMBER CONTAINED NEITHER  VALUE  DIGITS,
  419. C              NOR  DECIMAL  POINT,  NOR LEADING PLUS SIGN,
  420. C              NOR  LEADING  MINUS  SIGN.   THIS  VALUE  OF
  421. C              LSHIFT   IS   ALWAYS  RETURNED  IF  KIND  IS
  422. C              RETURNED CONTAINING A VALUE  OTHER  THAN  3.
  423. C              IF  KIND IS RETURNED CONTAINING THE VALUE 3,
  424. C              THEN ITRAIL MUST BE EITHER -3 OR 3, AND  THE
  425. C              CONTENTS OF THE INPUT TEXT BUFFER MUST BEGIN
  426. C              WITH A REPRESENTATION OF AN EXPONENT.
  427. C            = -3, A LEADING MINUS SIGN BUT NO VALUE DIGITS
  428. C              WAS FOUND.
  429. C            = -2, A LEADING PLUS SIGN BUT NO VALUE  DIGITS
  430. C              WAS FOUND.
  431. C            = -1, A LEADING PERIOD BUT NO VALUE DIGITS WAS
  432. C              FOUND.
  433. C            = 0, ONE OR MORE ZERO DIGITS WERE  FOUND,  BUT
  434. C              THE  NUMBER  CONTAINED  NO DIGITS OTHER THAN
  435. C              ZERO.  THE NUMBER REPRESENTATION MAY OR  MAY
  436. C              NOT  HAVE  BEEN  BEGUN  BY  A PLUS SIGN OR A
  437. C              MINUS SIGN AND MAY OR MAY NOT HAVE CONTAINED
  438. C              A DECIMAL POINT.
  439. C            = GREATER  THAN  ZERO,  LSHIFT  IS  NUMBER  OF
  440. C              DIGITS  COUNTING LEFTMOST NON-ZERO DIGIT AND
  441. C              ALL WHICH WERE SPECIFIED TO ITS RIGHT.  THIS
  442. C              IS  INDEPENDENT  OF  ANY  SHIFT IMPLIED BY A
  443. C              DECIMAL POINT OR EXPONENT
  444. C     IVALUE = RETURNED WITH VALUE IF KONTRL IS  LESS  THAN
  445. C              OR  EQUAL  TO  ZERO.  NOTE THAT IF KONTRL IS
  446. C              LESS THAN OR EQUAL TO  ZERO,  THEN  ORIGINAL
  447. C              CONTENT  OF IVALUE IS  ALWAYS DESTROYED.  IN
  448. C              PARTICULAR, IF KONTRL IS LESS THAN OR  EQUAL
  449. C              TO ZERO AND  IF KIND IS  RETURNED CONTAINING
  450. C              EITHER 1 OR 2, THEN IVALUE WILL BE ZEROED.
  451. C     VALUE  = RETURNED WITH VALUE  IF  KONTRL  IS  GREATER
  452. C              THAN  ZERO.   NOTE THAT IF KONTRL IS GREATER
  453. C              THAN ZERO,  THEN  THE  ORIGINAL  CONTENT  OF
  454. C              VALUE  IS  ALWAYS DESTROYED.  IN PARTICULAR,
  455. C              IF KONTRL IS GREATER THAN ZERO AND  IF  KIND
  456. C              IS RETURNED  CONTAINING EITHER  1 OR 2, THEN
  457. C              VALUE WILL BE ZEROED.
  458. C
  459.       CHARACTER*1 IBUFFR(MAXBFR),IDIGIT(10),KAPLTR(3),
  460.      1LOWLTR(3)
  461. C
  462.       DIMENSION JPOWER(3)
  463. C
  464.       CHARACTER*1 IPLUS,IMINUS,IDOT,IBLANK,ITAB,NOWLTR,
  465.      1 KAPEXP,LOWEXP
  466. C
  467. C     IDIGIT CONTAINS ALPHAMERIC FORM OF DIGITS 0 THRU 9
  468.       DATA IDIGIT/'0','1','2','3','4','5','6','7','8','9'/
  469. C
  470. C     IBLANK CONTAINS SPACE CHARACTER AND ITAB CONTAINS
  471. C     TAB CHARACTER.  IF TAB CHARACTER IS NOT AVAILABLE,
  472. C     ITAB SHOULD INSTEAD CONTAIN A SPACE ALSO.
  473. C
  474.       DATA IPLUS,IMINUS,IDOT,IBLANK,ITAB/
  475.      1'+','-','.',' ',' '/
  476. C
  477. C     KAPLTR = LIST OF UPPER CASE LETTERS WHICH CAN FOLLOW
  478. C              A NUMBER TO INDICATE AN EXPONENT.
  479. C     LOWLTR = LIST OF LOWER CASE LETTERS CORRESPONDING TO
  480. C              UPPER CASE LETTERS IN KAPLTR ARRAY.
  481. C     JPOWER = VALUE OF THE EXPONENT ASSOCIATED WITH THE
  482. C              PARALLEL CHARACTERS IN THE KAPLTR AND LOWLTR
  483. C              ARRAYS. JPOWER CAN BE NEGATIVE, FOR EXAMPLE
  484. C              PERCENT SIGN WOULD CORRESPOND TO JPOWER=-2.
  485. C     MAXTST = NUMBER OF ITEMS IN EACH OF KAPLTR, LOWLTR
  486. C              AND JPOWER ARRAYS.
  487. C     KAPEXP = UPPER CASE LETTER E
  488. C     LOWEXP = LOWER CASE LETTER E
  489. C
  490. C     UPPER CASE LETTERS CAN  BE SUBSTITUTED FOR LOWER CASE
  491. C     IN FOLLOWING DATA STATEMENTS,  IF COMPUTER UPON WHICH
  492. C     THIS ROUTINE IS USED DOES NOT SUPPORT LOWER CASE.
  493. C
  494.       DATA KAPLTR/'%','K','M'/
  495.       DATA LOWLTR/'%','k','m'/
  496.       DATA JPOWER/-2,3,6/
  497.       DATA MAXTST/3/
  498.       DATA KAPEXP,LOWEXP/'E','e'/
  499. C
  500. C     INITIALIZE
  501.       ISIGN=0
  502.       IF(KONTRL.GT.0)VALUE=0.0
  503.       IF(KONTRL.LE.0)IVALUE=0
  504.       ISHIFT=0
  505.       JSHIFT=0
  506.       KSHIFT=0
  507.       LSHIFT=-4
  508.       IRADIX=10
  509.       IF(KONTRL.LT.0)IRADIX=8
  510.       IADD=IRADIX-2
  511.       IPOWER=0
  512.       NUMKNT=-4
  513.       NUMVAL=0
  514.       NMBEXP=-1
  515.       NUMPNT=-1
  516.       IDEFLT=0
  517.       IF(ITRAIL.LT.-5)IDEFLT=1
  518.       KTRAIL=ITRAIL
  519.       IF(KTRAIL.GT.5)KTRAIL=KTRAIL-10
  520.       IF(KTRAIL.LT.-5)KTRAIL=KTRAIL+10
  521.       LTRAIL=KTRAIL
  522.       IF(LTRAIL.LT.0)LTRAIL=-LTRAIL
  523.       GO TO 2
  524. C
  525. C     *********************
  526. C     *  SCAN FOR NUMBER  *
  527. C     *********************
  528. C
  529. C     LOOP LOOKING AT CHARACTERS IN IBUFFR ARRAY
  530.     1 LOWBFR=LOWBFR+1
  531.     2 IF(LOWBFR.GT.MAXBFR)GO TO 25
  532.       NOWLTR=IBUFFR(LOWBFR)
  533.       IF(NMBEXP.GE.0)GO TO 20
  534.       IF(ISIGN.NE.0)GO TO 4
  535. C
  536. C     SCAN OVER LEADING SPACES AND/OR TABS
  537.       IF(NOWLTR.EQ.IBLANK)GO TO 1
  538.       IF(NOWLTR.EQ.ITAB)GO TO 1
  539. C
  540. C     LOOK FOR INITIAL SIGNS + OR -
  541.       IF(KONTRL.LE.-2)GO TO 40
  542.       IF(LTRAIL.GE.3)GO TO 4
  543.       IF(NOWLTR.EQ.IPLUS)GO TO 3
  544.       IF(NOWLTR.NE.IMINUS)GO TO 4
  545.       ISIGN=-1
  546.       NUMKNT=-3
  547.       GO TO 1
  548.     3 ISIGN=1
  549.       NUMKNT=-2
  550.       GO TO 1
  551. C
  552. C     LOOK FOR % K OR M FOLLOWING NUMBER
  553. C     LOCK OUT THESE AND ALSO E IF NO PART OF NUMBER FOUND
  554.     4 IF(LTRAIL.GE.2)GO TO 5
  555.       IF(ISIGN.EQ.0)GO TO 10
  556.       IF(KTRAIL.EQ.0)GO TO 10
  557.     5 IF(KTRAIL.LT.0)GO TO 8
  558.       I=0
  559.     6 I=I+1
  560.       IF(I.GT.MAXTST)GO TO 8
  561.       IF(NOWLTR.EQ.KAPLTR(I))GO TO 7
  562.       IF(NOWLTR.NE.LOWLTR(I))GO TO 6
  563.     7 IPOWER=JPOWER(I)
  564.       JSIGN=1
  565.       NMBEXP=1
  566.       ISHIFT=I
  567.       LOWBFR=LOWBFR+1
  568.       GO TO 26
  569. C
  570. C     LOOK FOR LETTER E
  571.     8 IF(NOWLTR.EQ.KAPEXP)GO TO 9
  572.       IF(NOWLTR.NE.LOWEXP)GO TO 10
  573.     9 JSIGN=0
  574.       NMBEXP=0
  575.       ISHIFT=-4
  576.       GO TO 19
  577. C
  578. C     LOOK FOR LEADING OR EMBEDDED PERIOD
  579.    10 IF(LTRAIL.GE.3)GO TO 24
  580.       IF(NUMPNT.GE.0)GO TO 11
  581.       IF(NOWLTR.NE.IDOT)GO TO 11
  582.       DECML=0.1
  583.       IF(ISIGN.EQ.0)NUMKNT=-1
  584.       GO TO 18
  585. C
  586. C     LOOK FOR DIGIT OTHER THAN IN EXPONENT FIELD
  587.    11 DO 16 I=1,IRADIX
  588.       IF(NOWLTR.NE.IDIGIT(I))GO TO 16
  589.       IF(NUMKNT.GT.0)GO TO 12
  590.       NUMKNT=0
  591.       IF(I.EQ.1)GO TO 13
  592.    12 NUMKNT=NUMKNT+1
  593.    13 IF(KONTRL.LE.0)GO TO 15
  594.       IF(NUMKNT.LE.KONTRL)NUMVAL=(10*NUMVAL)+I-1
  595.       IF(NUMPNT.GE.0)GO TO 14
  596.       VALUE=(10.0*VALUE)+FLOAT(I-1)
  597.       GO TO 19
  598.    14 VALUE=VALUE+(DECML*FLOAT(I-1))
  599.       DECML=DECML/10.0
  600.       GO TO 18
  601. C     FOLLOWING ALLOWS LARGEST NEGATIVE NUMBER FOR
  602. C     WHICH THERE IS NOT CORRESPONDING POSITIVE VALUE
  603.    15 IF(NUMKNT.EQ.1)IVALUE=I-2
  604.       IF(NUMKNT.GT.1)IVALUE=(IRADIX*IVALUE)+I+IADD
  605.       GO TO 17
  606.    16 CONTINUE
  607.       GO TO 24
  608. C
  609. C     DIGIT, E OR . FOUND SO MARK AS BEING IN NUMBER
  610.    17 IF(NUMPNT.LT.0)GO TO 19
  611.    18 NUMPNT=NUMPNT+1
  612.    19 IF(ISIGN.EQ.0)ISIGN=1
  613.       GO TO 1
  614. C
  615. C     LOOK FOR SIGN IN EXPONENT FIELD
  616.    20 IF(JSIGN.NE.0)GO TO 22
  617.       IF(NOWLTR.EQ.IPLUS)GO TO 21
  618.       IF(NOWLTR.NE.IMINUS)GO TO 22
  619.       JSIGN=-1
  620.       ISHIFT=-3
  621.       GO TO 1
  622.    21 JSIGN=1
  623.       ISHIFT=-2
  624.       GO TO 1
  625. C
  626. C     LOOK FOR DIGITS IN EXPONENT FIELD
  627.    22 DO 23 I=1,10
  628.       IF(NOWLTR.NE.IDIGIT(I))GO TO 23
  629.       IPOWER=(10*IPOWER)+I-1
  630.       NMBEXP=1
  631.       ISHIFT=-1
  632.       IF(JSIGN.EQ.0)JSIGN=1
  633.       GO TO 1
  634.    23 CONTINUE
  635.       GO TO 26
  636. C
  637. C     DECIDE WHAT TO DO IF NO MATCH FOUND
  638.    24 IF(ISIGN.NE.0)GO TO 26
  639.       GO TO 40
  640. C
  641. C     *******************************
  642. C     *  NUMBER HAS BEEN EVALUATED  *
  643. C     *******************************
  644. C
  645.    25 IF(ISIGN.EQ.0)GO TO 39
  646.    26 KIND=3
  647. C
  648. C     ADJUST EXPONENT SIGN
  649.       IF(NMBEXP.LT.0)GO TO 27
  650.       IF(NMBEXP.EQ.0)IPOWER=IDEFLT
  651.       IF(JSIGN.LT.0)IPOWER=-IPOWER
  652. C
  653. C     SHIFT FLOATING POINT NUMBER ACCORDING TO EXPONENT
  654.    27 JSHIFT=IPOWER
  655.       KSHIFT=IPOWER
  656.       IF(NUMPNT.GT.0)KSHIFT=KSHIFT-NUMPNT
  657.       LSHIFT=NUMKNT
  658.       IF(NUMPNT.LT.0)NUMPNT=0
  659.       IF(ITRAIL.GT.5)IPOWER=NUMPNT
  660.       IPOWER=IPOWER+IEXTRA
  661.       IF(KONTRL.LE.0)GO TO 31
  662.       IF(NUMKNT.GT.KONTRL)GO TO 28
  663.       IF(NUMKNT.LT.0)NUMVAL=IDEFLT
  664.       IF(ISIGN.LT.0)NUMVAL=-NUMVAL
  665.       VALUE=FLOAT(NUMVAL)
  666.       IPOWER=IPOWER-NUMPNT
  667.       GO TO 29
  668.    28 IF(NUMKNT.LT.0)VALUE=IDEFLT
  669.       IF(ISIGN.LT.0)VALUE=-VALUE
  670.    29 IF(IPOWER.EQ.0)GO TO 41
  671.       IF(IPOWER.GT.0)GO TO 30
  672.       IPOWER=-IPOWER
  673.       VALUE=VALUE/(10.0**IPOWER)
  674.       GO TO 41
  675.    30 VALUE=VALUE*(10.0**IPOWER)
  676.       GO TO 41
  677. C
  678. C     SHIFT AN INTEGER ACCORDING TO EXPONENT
  679.    31 IF(NUMKNT.LT.0)IVALUE=IDEFLT
  680.       IPOWER=IPOWER-NUMPNT
  681.       IF(ISIGN.GE.0)GO TO 32
  682.       IVALUE=-IVALUE
  683. C     NOTE THAT NEGATIVE NUMBER  AT THIS POINT HAS ABSOLUTE
  684. C     VALUE 1 TOO LOW  TO ALLOW THE LARGEST NEGATIVE NUMBER
  685. C     WHICH  HAS NO CORRESPONDING  POSITIVE  VALUE  IN TWOS
  686. C     COMPLEMENT NOTATION
  687.       IF(NUMKNT.GT.0)IVALUE=IVALUE-1
  688.       GO TO 33
  689.    32 IF(NUMKNT.GT.0)IVALUE=IVALUE+1
  690.    33 IF(IPOWER.LE.0)GO TO 37
  691.       IPOWER=IPOWER-1
  692.       KVALUE=IVALUE
  693.       IVALUE=IRADIX*IVALUE
  694.       IF(ISIGN.GE.0)GO TO 34
  695.       IF(IVALUE.GE.KVALUE)GO TO 36
  696.       GO TO 35
  697.    34 IF(IVALUE.LE.KVALUE)GO TO 36
  698.    35 IF((IVALUE/IRADIX).EQ.KVALUE)GO TO 33
  699.    36 IVALUE=KVALUE
  700.    37 IF(IPOWER.GE.0)GO TO 41
  701.       IPOWER=IPOWER+1
  702.       KVALUE=IVALUE
  703.       IVALUE=IVALUE/IRADIX
  704.       IF(ISIGN.GE.0)GO TO 38
  705.       IF((IRADIX*IVALUE).LT.KVALUE)IVALUE=IVALUE+1
  706.    38 IF(IVALUE.NE.0)GO TO 37
  707.       GO TO 41
  708. C
  709. C     NUMBER NOT FOUND
  710.    39 KIND=1
  711.       GO TO 41
  712.    40 KIND=2
  713. C
  714. C     RETURN TO CALLING PROGRAM
  715.    41 RETURN
  716. C
  717. C     IBLANK = THE BLANK OR SPACE CHARACTER
  718. C     JSIGN  = 0, NEITHER SIGN NOR DIGITS AFTER E
  719. C            = 1, EITHER PLUS OR DIGITS AFTER E
  720. C            = -1, MINUS SIGN AFTER E
  721. C     ITAB   = THE TAB CHARACTER
  722. C     ISIGN  = 0, NO PART OF NUMBER ENCOUNTERED
  723. C            = -1, MINUS SIGN AT START OF NUMBER
  724. C            = 1, NUMBER DOES NOT START WITH MINUS SIGN
  725. C     NMBEXP = -1, NO EXPONENT FIELD YET FOUND
  726. C            = 0, EXPONENT FIELD FOUND BUT NUMBER NOT
  727. C              YET FOUND
  728. C            = 1, NUMBER FOUND IN EXPONENT FIELD
  729. C     NOWLTR = THE CHARACTER CURRENTLY BEING TESTED
  730. C     NUMKNT = NUMBER OF DIGITS IN VALUE FIELD
  731. C            = 0, LEFT HAND ZERO ONLY READ SO FAR
  732. C            = -1, NO DIGITS YET FOUND
  733. C     NUMPNT = -1, DECIMAL POINT NOT YET FOUND
  734. C            = 0, DECIMAL POINT ENCOUNTERED IN VALUE FIELD
  735. C            = .GT.0, VALUE IS NUMBER OF DIGITS ENCOUNTERED
  736. C              TO RIGHT OF DECIMAL POINT IN NUMBER.
  737.       END
  738.